home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Module source / tool.txt < prev    next >
Text File  |  1993-02-01  |  8KB  |  373 lines
  1. \ Construct table of names & traps for toolbox calls
  2.  
  3. false    value        DOING_GLOBALS?
  4.     9    constant    TAB
  5.  
  6. :class    CSARRAY  super{ object }  16 indexed
  7.  
  8. :m AT:        \ ( index -- addr len )
  9.     ^elem  count  ;m
  10.  
  11. :m TO:        \ ( addr len index -- )
  12.     ^elem  place  ;m
  13.  
  14. ;class
  15.  
  16.  
  17. :class    WARRAY  super{ object }  2 indexed
  18.  
  19. :m  AT:        \ ( index -- n )
  20.     inline{ ix w@}
  21.     ^elem  w@  ;m
  22.  
  23. :m  TO:        \ ( n index -- )
  24.     inline{ ix w!}
  25.     ^elem  w!  ;m
  26.  
  27. :m  +TO:    \ ( n index -- )
  28.     inline{ ix w+!}
  29.     ^elem  w+!  ;m
  30.  
  31. :m -TO:        \ ( n index -- )
  32.     inline{ ix w-!}
  33.     ^elem  w-!  ;m
  34.  
  35. :m ^ELEM:    \ ( index -- addr )
  36.     inline{ ix}
  37.     ^elem4  ;m
  38.  
  39. :m FILL:    \ ( value -- )  Fills all elements with value.
  40.     idxbase  limit 2*  bounds
  41.     ?DO  dup  i w!  2 +LOOP  drop  ;m
  42.  
  43. ;class
  44.  
  45.  
  46. :class    COUNTED_STRINGS  super{ object }  1 indexed
  47.  
  48.     int    SIZE
  49.  
  50. :m GETSIZE:    get: size  ;m
  51.  
  52. :m ADD:  { addr len -- }
  53.     addr len  get: size  ^elem1  place
  54.     get: size  len +  1+  put: size  ;m
  55.  
  56. :m AT:        \ ( idx -- addr len )
  57.     ^elem1  count  ;m
  58.  
  59. ;class
  60.  
  61.  
  62. :class    HASHTABLE  super{ array }
  63.  
  64.     int    MASK
  65.  
  66. private
  67.  
  68. :m LOOKUP:  { val \ ixb strt end addr -- index b }
  69.     idxbase -> ixb
  70.     val  get: mask  and  ixb +  dup -> strt -> addr
  71.     ixb  get: mask +  1+  -> end
  72.     BEGIN
  73.         addr @  NIF  addr idxbase -  4/  false  EXIT  THEN
  74.         addr @  val =
  75.         IF  ( found )
  76.             addr ixb -  4/  true  EXIT
  77.         THEN
  78.         4 ++> addr  addr end >=
  79.         IF    ixb -> addr
  80.         ELSE    addr strt =  IF  50 die  THEN
  81.         THEN
  82.     AGAIN  ;m
  83.  
  84. public
  85.  
  86. :m INDEXOF:    \ ( val -- index T  |  -- F )
  87.     lookup: self  IF  true  EXIT  THEN
  88.     drop  false  ;m
  89.  
  90. :m ENTER:  { val \ idx found? -- idx b }
  91.     val  lookup: self  -> found?  -> idx
  92.     found? iF  idx  false  EXIT  THEN
  93.     val idx to: super  idx true  ;m
  94.     
  95.  
  96. :m CLASSINIT:
  97.     limit  1-  2 <<  put: mask  ;m
  98.  
  99. ;class
  100.  
  101.  
  102. :class  STRINGARRAY  super{ string array }
  103.  
  104.     int    CURRENT
  105.  
  106. :m CURRENT:
  107.     get: current  ;m
  108.  
  109. :m (SEL):  { idx -- }
  110.     idx  put: current
  111.     idx at: self  ^base !
  112.     nil?: self  ?EXIT
  113.     ^base  size: handle  put: size  ;m
  114.  
  115. :m SELECT:  { idx -- }
  116.     idx (sel): self
  117.     nil?: self
  118.     IF        \ new: not done - do it now
  119.         new: super
  120.         handle: self  idx to: self
  121.     ELSE
  122.         reset: self
  123.     THEN  ;m
  124.  
  125. :m RELEASE:
  126.     limit 0 DO
  127.         i (sel): self  release: super    \ Harmless if not open
  128.         nilH  i to: self
  129.     LOOP  ;m
  130.  
  131. :m CLEARALL:
  132.     limit 0 DO
  133.         i (sel): self
  134.         handle: self  IF  clear: super  THEN
  135.     LOOP  ;m
  136.  
  137. :m DUMP:
  138.     ." Current:"  get: current  .  cr
  139.     dump: super  ;m
  140.  
  141. :m CLASSINIT:
  142.     idxbase  limit 4*  bounds
  143.     DO  nilH  i !  4 +LOOP  ;m
  144.  
  145. ;class
  146.  
  147.  
  148. string TEMP
  149.  
  150. 2048    hashtable    TRAPNAMES
  151. 2048    Warray        TRAP_INDEXES
  152. 10000    counted_strings    TRAPS
  153. 2048    stringarray    $TNAMES
  154.  
  155. 512    hashtable    GNAMES
  156. 512    array        GLOBALS
  157.  
  158. 4096    hashtable    KNAMES
  159. 4096    array        KONSTANTS
  160.  
  161.     0    value    #DBL
  162.     0    value    #TRAPS
  163.     0    value    #GLOBALS
  164.     0    value    #KONSTANTS
  165.  
  166.  
  167. : CHAROF { addr chr -- offs T | -- F }
  168.         \ Addr is of a str255 string.  Offs refers to found char.
  169.     addr count  chr  scan
  170.     IF  addr - 1-  true  ELSE  drop false  THEN  ;
  171.  
  172.  
  173. : READ_INLINE  { \ loc -- }
  174.     clear: temp
  175.     begin
  176.         >in @  src-len  >=  ?exit
  177.         hex intrp1  pad w!  pad 2 add: temp
  178.     again  ;
  179.  
  180.  
  181. true    value    DBLFAIL?
  182.  
  183. : TRAPNAME  { \ hashval s255 idx dbl? -- }
  184.  
  185.     source bl scan
  186.     ( addr len ) IF  1+ src-start -  >in !  ELSE  drop  THEN
  187.  
  188.     Mword  -> s255            \ Trap name
  189.     s255 hash  -> hashval
  190.     hashval  enter: trapnames  not -> dbl?  -> idx
  191.     dbl? IF
  192.         idx select: $tnames  get: $tnames  s255 count  s=
  193.         NIF  here count cr type ."  - hash collision!!" cr abort  THEN
  194.         1 ++> #dbl  EXIT
  195.     THEN
  196.     idx select: $tnames  s255 count put: $tnames
  197.     read_inline
  198.     getSize: traps  idx  to: trap_indexes
  199.     all: temp  add: traps
  200.     1 ++> #traps  ;
  201.  
  202.  
  203. : GLOBNAME  { \ hashval val s255 -- }
  204.     \ Gets next word, adds if tool name, records parm if applicable
  205.     Mword hex number  -> val    \ global value
  206.     Mword -> s255            \ name
  207.     s255 hash  -> hashval
  208.     hashval  enter: gnames
  209.     NIF  ( match - check for hash collision )
  210.         at: globals  val <>
  211.         IF  ( hash collision - FAIL )
  212.             here count cr type ."  - hash collision!!" cr abort
  213.         THEN
  214.         1 ++> #dbl   EXIT
  215.     THEN
  216.     val swap to: globals  1 ++> #globals  ;
  217.  
  218.  
  219. : HANDLE_LINE        \ ( glob? -- )
  220.     IF  globname  ELSE  trapname  THEN  ;
  221.  
  222.  
  223. : TOOLS" { glob? \ radix svecho -- }
  224.             \ Reads toolbox name/trap table and fills arrays.
  225.     base -> radix  echo? -> svecho
  226.     new: temp
  227.     pushNew: loadFile  setName: topfile
  228.     openReadOnly: topfile  ?error 149
  229.     false -> endload?
  230.     begin  ( read until eof )
  231.         (Frefill)
  232.     while
  233.         tib c@  & \  <>            \ skip comments
  234.         if  glob? handle_line  then
  235.     repeat
  236.     drop: loadFile
  237.     release: temp
  238.     radix -> base  svecho -> echo?  ;
  239.  
  240.  
  241. \ The "konstants" file can be interpreted as a source file, since
  242. \ it consists of lines of the form
  243. \
  244. \ 1234 konstant    Name
  245. \
  246. \ The following word KONSTANT does the hard work.
  247.  
  248. : KONSTANT    \ ( value --<name> )
  249.     dup   constant        \ Define the name as a constant so
  250.                     \  later konsts can refer to it
  251.     latest  hash        \ Get the name, hash it
  252.     enter: knames
  253.     NIF  ( match - check for hash collision )
  254.         at: konstants  <>
  255.         IF  ( hash collision - FAIL )
  256.             here count cr type ."  - hash collision!!" cr abort
  257.         THEN
  258.         1 ++> #dbl   EXIT
  259.     THEN
  260.     to: konstants  1 ++> #konstants  ;
  261.  
  262.  
  263. : 'TYPEX    \ ( --< 'xxxx' > )  Modified 'TYPE to use with KONSTANT
  264.     pad 4 bl fill
  265.     & '  scan-src  source drop  & '  scan-src
  266.     source drop  over -  4 min
  267.     pad swap cmove  pad @  postpone lit  ;        immediate
  268.  
  269.  
  270. \ load the calls etc.
  271.  
  272.     4    constant  midiToolNum
  273. $ A830    constant  _pack14
  274.  
  275.             false -> dblFail?
  276. cr  .( Loading trap names...)            false tools" calls"
  277. cr  #dbl .    .( double-ups - ignore them)   0 -> #dbl
  278. cr  #traps .    .( trap names stored.  )
  279. cr  getSize: traps .    .(  bytes used for traps storage)
  280.  
  281. release: $tnames
  282.  
  283. cr  .( Loading low memory global names...)    true  tools" globals"
  284. cr  #globals .    .( global names stored)
  285. cr  #dbl .    .( double-ups in globals)    0 -> #dbl
  286. cr  .( Loading konsts...)
  287. // konstants
  288. cr  #konstants  .    .( konsts stored)
  289. cr  #dbl .    .( double-ups in konsts)    0 -> #dbl
  290.  
  291. forget read_inline        \ dump table generation code
  292.  
  293.  
  294. : @TRAP  { tStr \ mStr flg addr len -- addr len }
  295.         \ Gets inline call sequence for a trap name.  tStr is str255.
  296.     tStr count  2 min  " PB"  s=
  297.     IF  ( PB file calls now have the PB omitted )
  298.         tStr count 2 /string  str255  -> tStr
  299.     THEN
  300.     0 -> mStr
  301.     tStr  & ,  charOf            \ stop short of comma if any
  302.     IF  dup tStr c! tStr + 2+ -> mStr  THEN
  303.     tStr hash  indexOf: trapnames  not ?error 150
  304.     at: trap_indexes  at: traps  -> len  -> addr    \ That's the call sequence
  305.     mStr IF                        \ a modifier exists
  306.         true
  307.         CASE
  308.             mStr 4 " REGS"    s= OF $ 01  ENDOF \ GetTrapAddr
  309.             mStr 5 " ASYNC"    s= OF $ 04  ENDOF \ device drivers
  310.             mStr 5 " IMMED"    s= OF $ 02  ENDOF \ control calls
  311.             mStr 3 " SYS"    s= OF $ 04  ENDOF \ Memory Manager
  312.             mStr 5 " CLEAR"    s= OF $ 02  ENDOF
  313.             mStr 5 " MARKS"    s= OF $ 04  ENDOF \ String Compares
  314.             mStr 4 " CASE"    s= OF $ 02  ENDOF
  315.             164 die            \ Illegal modifier name
  316.         ENDCASE
  317.         addr c@  $ F0 and  $ A0 <>  ?error 151    \ call seq must start $Axxx
  318.         addr pad len cmove  pad -> addr
  319.         addr c@ or  addr c!    
  320.     THEN
  321.     addr len  ;
  322.  
  323. : @GLOB        \ ( str-addr -- glob# )
  324.     hash  indexOf: gnames  0= ?error 150
  325.     at: globals  ;
  326.  
  327. : @KONST    \ ( str-addr -- konst )
  328.     hash  indexOf: knames  0= ?error 150
  329.     at: konstants  ;
  330.  
  331. : (,TRAP)    \ ( addr len -- )
  332.     tuck  here swap cmove  align allot  ;
  333.  
  334.  
  335. : ,TRAP        \ ( addr len -- )  Compiles the given inline code sequence.
  336.     SavA5  (,trap)  RstA5  ;
  337.  
  338.  
  339. : ,FCALL        \ Trap dispatcher for low-level File Manager
  340.     $ 205E w,        \    move.l    (a6)+,a0    ; FCB pointer
  341.     ,trap
  342.     $ 48C0 w,        \    ext.l    d0            ; Result
  343.     $ 2D00 w,  ;    \    move.l    d0,-(a6)
  344.  
  345.  
  346. \ Now the exported words:
  347.  
  348. : ASMCALL    \ ( addr len -- )  Compiles the trap.
  349.     str255 count upper
  350.     buf255  @trap
  351.     tuck  here swap cmove  align allot  ;
  352.  
  353. : CALL
  354.     ?comp
  355.     Mword  @Trap  ,trap  ;        immediate
  356.  
  357. : FCALL
  358.     ?comp
  359.     Mword  @Trap  ,fcall  ;        immediate
  360.  
  361. : GLOBAL
  362.     Mword  @glob  postpone lit  ;    immediate
  363.  
  364. : $>GLOB    \ ( addr len -- glob )
  365.     str255 count upper  buf255  @glob  ;
  366.  
  367.  
  368. : KONST
  369.     Mword  @konst  postpone lit  ;    immediate
  370.  
  371. : $>KONST    \ ( addr len -- konst )
  372.     str255 count upper  buf255  @konst  ;
  373.